Wonky Flux Batch 2019 02

home *** CD-ROM | disk | FTP | other *** search

/ Wonky Flux Batch 2019 02 / Wonky_Flux_Batch_2019-02.zip / Wonky Flux Batch 2019-02 / 090 - CAD Draw.dsk / T.APSOFT III.s < prev next >

Wrap

Text File | 2019-02-17 | 37KB | 1,295 lines

PAG ***************************** * T * * Applesofto]J art III * * {{{ * * Copywrite Apple Computer, * * Inc. and Microsoft, Inc.; * * not for publication or * * distribution. * * * ***************************** * * * Floating Point Routines * * * * $E7A0 - $F1D4 * * * ***************************** FADDH LDA #HALF ;FAC+1/2 -> FAC LDY #>HALF JMP FADD FSUB JSR CONUPK ;Load ARG from (A,Y) FSUBT >>> NEG.FACSGN ;ARG - FAC -> FAC EOR ARGSGN STA SGNCPR LDA FAC JMP FADDT AD0 JSR SHIFT ;Do byte shift BCC AD5 ;Always taken FADD JSR CONUPK ;(A,Y) to ARG FADDT BNE AD1 ;ARG + FAC -> FAC JMP MOVFA ;If FAC=0 just move ARG over AD1 LDX EXTRAFAC ;Extra byte for precision STX EXTRASV ; in all FP routines. LDX #ARG ;Set up to shift ARG LDA ARG AD2 TAY BEQ RTN4 ;If ARG=0 exit SEC SBC FAC ;Get diffnce of exp BEQ AD5 ;Go add if same exp BCC AD3 STY FAC ;Sneaky exchange LDY ARGSGN STY FACSGN EOR #$FF ADC #0 LDY #0 STY EXTRASV LDX #FAC ;Set up to shift FAC BNE AD4 AD3 LDY #0 STY EXTRAFAC AD4 CMP #$F9 ;How many bits to shift? BMI AD0 ;Branch if more than 7 TAY ;Index to # of shifts LDA EXTRAFAC LSR 1,X JSR SHFTR ;Do shift AD5 BIT SGNCPR ;Same sign? BPL ADMAN ;Yes, add mantiss|FW LDY #FAC CPX #ARG ;Which was adjusted? BEQ SUBMAN ;If=tG, do FAC-ARG LDY >pG ;If FAC, do ARG-FAC SUBMAN SEC EOR #$[sW ADC EXTRASV STA EXTRAFAC >>>=.4,Y ;4,X;FAC+4 >>> SB.3,Y ;3,X;FAC+3 >>> SB.2,Y ;2,X;FAC+2 >>> SB.1,Y ;1,X;FAC+1 SGNIF BCS SIGNIF ;Branch if difference posv JSR NEGFAC SIGNIF LDY #0 ;Shift up signif digit TYA ;Counting shift in A CLC FLOOP LDX FAC+1 BNE FR2 ;Repeatill not 5t1DX FAC+2 STX FAC+1 LDX FAC+3 STX FAC+2 LDX FAC+4 STX FAC+3 LDX EXTRAFAC STX FAC+4 STY EXTRAFAC ;Zero extra byte ADC #8 ;Count the 8 bits CMP #8*4 ;Done 4 times? BNE FLOOP ;Loop if not ZEROFAC LDA #0 AtoFAC STA FAC AtoFACS STA FACSGN RTS ADMAN ADC EXTRASV ;Add mantissas (frac parts) STA EXTRAFAC >>> AD.FAC+4 ;ARG+4;FAC+4 >>> AD.FAC+3 ;ARG+3;FAC+3 >>> AD.FAC+2 ;ARG+2;FAC+2 >>> AD.FAC+1 ;ARG+1;FAC+1 JMP FR3 bDVa{UxFdIRh/7$lX0z($VT]`lxzMNaf&,8"jWJ7<t5#:i%0Q.i]d~ Q"k,Dz,#X~HSTs@FR1 ;Repeat till FAC+1 neg SEC SBC FAC ;Fix exponent BCS ZEROFAC EOR #$FF ADC #1 STA FAC ;Carry is clear here FR3 BCC RTN5 FROUND INC FAC BEQ OVERFLOW ROR FAC+1 ROR FAC+2 ROR FAC+3 ROR FAC+4 ROR EXTRAFAC RTN5 RTS NEGFAC >>> NEG.FACSGN ;Take ones complement NEG2 >>> NEG.FAC+1 >>> NEG.FAC+2 >>> NEG.FAC+3 >>> NEG.FAC+4 >>> NEG.EXTRAFAC INC EXTRAFAC ;Add bit to get BNE RTN6 ; twos complement PLUSEPS INC FAC+4 ;Add carry from EXTRA BNE RTN3 IN@ FAC+3 BNE RTN6 INC FAC+2 BNE W-_lq%Pr(_4}0+::Q3\nFLOW bX #OVFLOW-ERRMSG JMP ERROR SHFTRES LDX #RESULT-1 ;Entry from FMULT but carry NXSFT LDY 4,X ; should have been set! STY EXTRAFAC LDY 3,X STY 4,X LDY 2,X STY 3,X LDY 1,X STY 2,X LDY FPGEN ;$FF if from QINT for neg # STY 1,X ; otherwise 0 SHIFT ADC #8 ;Shift 1,X right $100-A bits BMI NXSFT ;Do byte shift if in range BEQ NXSFT SBC #8 TAY ;Count for final bit shift LDA EXTRAFAC BCS SH3 ;Exit if none needed SH1 ASL 1,X ;Shift only the lower 7 bits BCC SH2 ; of 1,X INC 1,X ;Force next instrn to set carry SH2 ROR 1,X ROR 1,X SHFTR ROR 2,X ROR 3,X ROR 4,X ROR INY BNE SH1 SH3 CLC RTS ONE HEX 8100000000 LOGSER DFB 3 ;Index to # of coefs: HEX 7F5E56CB79 HEX 80139B0B64 HEX 8076389316 HEX 8238AA3B20 SQRhalf HEX 803504F334 ;SQR(1/2) SQRtwo HEX 813504F334 ;SQR(2) HALFneg HEX 8080000000 ;-1/2 LOGtwo HEX 80317217F8 ;ln(2) LOG JSR SIGN ;Natural log of FAC BEQ GIQ ;Argument must be > 0 BPL LG2 GIQ JMP IQERR LG2 LDA FAC ;Save exponent-$80 SBC #$7F ;Carry is c;jar PHA LDA #$80 ;Normalize between .5 and 1 STA FAC LDA #SQRhalf LDY #>SQRhalf JSR FADD ;Compute via series of odd LDA #SQRtwo ; powers of LDY #>SQRtwo ; (SQR(2)X-1)/(SQR(2)X+1) JSR FDIV LDA #ONE LDY #>ONE JSR FSUB LDA #LOGSER LDY #>LOGSER JS[ ODDSER ;Computes LOG +.5 base 2 LDA #HALFneg LDY #>HALFneg JSR FADD PLA JSR ADDACC ;Add original exponent - $80 LDA #LOGtwo ;Now have LOG base 2, convert LDY #>LOGtwo ; to base e by *LOG(2). FMULT JSR CONUPK ;(A,Y) to ARG FMULTT BNE FMU ;FAC * ARG -> FAC JMP RTN7 ;Should just RTS FMU JSR ADEXP LDA #0 ;Init product STA RESULT STA RESULT+1 STA RESULT+2 STA RESULT+3 LDA EXTRAFAC ;Multiply digits of FAC by JSR FM1 ; ARG and add to RESULT LDA FAC+4 JSR FM1 LDA FAC+3 JSR FM1 LDA FAC+2 JSR FM1 LDA FAC+1 JSR FM2 JMP RES>FAC ;Move RESULT to FAC & normalize * Routine to multiply A-reg by ARG and add to RESULT. FM1 BNE FM2 ;Do 8 bit mult if not 0 * BUG: There should be a SEC here. Usually it is set * since FM2 leaves it that way, but SHFTRES leaves it * clear. Using SHFTRES from THIS entry assumes carry * set. Thus, if SHFTRES is used twice in a row then * calculation will be off in the last 8 bits! This * happens when FAC+2, FAC+3 are both 0 but FAC+4 is * nonzero. For example, try PRINT 1*998244415 or * PRINT 1*10.0000009 JMP SHFTRES ;Shift product one byte ; (used for extra speed) FM2 LSR ;Shift off low bit ORA #$80 ;Set for 8 bit count FM3 TAY ;Save it BCC FM4 ;Branch if low bit = 0 CLC ;Mult bit by ARG to RESULT >>> AD.RESULT+3;ARG+4;RESULT+3 >>> AD.RESULT+2;ARG+3;RESULT+2 >>> AD.RESULT+1;ARG+2;RESULT+1 >>> AD.RESULT ;ARG+1;RESULT FM4 ROR RESULT ;Shift product one bit ROR RESULT+1 ROR RESULT+2 ROR RESULT+3 ROR EXTRAFAC TYA ;Retrieve acc LSR ;Shift off next bit BNE FM3 ;Loop 8 times (via the ORA #$80) RTN7 RTS * Unpack number at (A,Y) and move to ARG: CONUPK STA INDEX STY INDEX+1 LDY #4 LDA (INDEX),Y STA ARG+4 DEY LDA (INDEX),Y STA ARG+3 DEY LDA (INDEX),Y STA ARG+2 DEY LDA (INDEX),Y STA ARGSGN ;Store sign EOR FACSGN STA SGNCPR ;Set sign comparison LDA ARGSGN ;Retrieve MSB ORA #$80 ;Set leading bit STA ARG+1 ;Store MSB DEY LDA (INDEX),Y STA ARG ;Store exp LDA FAC ;To set status reg RTS ADEXP LDA ARG ADEX2 BEQ ZERO CLC ADC FAC BCC ADEX3 ;Branch if no overflow BMI JOV CLC ;Ok since +$80 will not ovflow HEX 2C ;Trick to branch ADEX3 BPL ZERO ;Underflow if still + ADC #$80 ;Correct for $80 displacement STA FAC BNE ADEX4 JMP AtoFACS ADEX4 LDA SGNCPR STA FACSGN RTS OUTOFRNG LDA FACSGN EOR #$FF BMI JOV ;Error if positive # ZERO PLA PLA JMP ZEROFAC ;Return 0 if negative # JOV JMP OVERFLOW * Routine to multiply FAC by 10: MUL10 JSR MOVAF ;Copy FAC to ARG TAX ;A-reg holds FAC BEQ RTN8 ;Exit if FAC=0 CLC ADC #2 ;Simulate *4 BCS JOV LDX #0 ;Flag we are adding things STX SGNCPR ; of same sign. JSR AD2 ;FAC*4 + ARG -> FAC INC FAC ;= mult by 2 BEQ JOV RTN8 RTS NUM10 HEX 8420000000 * Routine to divide ABS(FAC) by 10: DIV10 JSR MOVAF ;Copy FAC to ARG LDA #NUM10 ;Set up to put LDY #>NUM10 ; 10 in FAC LDX #0 DIV STX SGNCPR JSR MOVFM ;Put (A,Y) in FAC JMP FDIVT ;Divide ARG by FAC FDIV JSR CONUPK ;(A,Y) -> ARG FDIVT BEQ DIVZ ;ARG/FAC -> FAC JSR RNDB LDA #0 SEC SBC FAC STA FAC JSR ADEXP ;Get exp of ARG/(2*FAC) INC FAC ;*2 BEQ JOV LDX #-4 ;Looping index LDA #1 ;Bit count & partial quotient FD1 LDY ARG+1 ;Is ARG >= FAC? CPY FAC+1 BNE FD2 LDY ARG+2 CPY FAC+2 BNE FD2 LDY ARG+3 CPY FAC+3 BNE FD2 LDY ARG+4 CPY FAC+4 FD2 PHP ; carry set if so. ROL ;Bump bit count & rot quot bit BCC FD3 ;Skip until 8 bits done INX ;Bump loop index STA RESULT+3,X ;Store a quotient byte BEQ FD6 ;Branch if last one BPL FD7 ;Final exit when X=1 LDA #1 ;Reset bit count FD3 PLP ;Was ARG >= FAC? BCS FD5 ;Subtract divisor if so FD4 ASL ARG+4 ;Shift ARG one bit ROL ARG+3 ROL ARG+2 ROL ARG+1 BCS FD2 ;Branch if new ARG overflows BMI FD1 ;Check if can divide BPL FD2 ;No comparison needed FD5 TAY ;Protect partial quotient >>> SB.ARG+4 ;FAC+4;ARG+4 >>> SB.ARG+3 ;FAC+3;ARG+3 >>> SB.ARG+2 ;FAC+2;ARG+2 >>> SB.ARG+1 ;FAC+1;ARG+1 TYA JMP FD4 FD6 LDA #$40 ;Set bit count for last one BNE FD3 ;Always FD7 LUP 6 ASL --^ STA EXTRAFAC ;Last two bits to EXTRAFAC PLP JMP RES>FAC DIVZ LDX #DIVbyZRO-ERRMSG JMP ERROR RES>FAC >>> TRDB.RESULT;FAC+1 >>> TRDB.RESULT+2;FAC+3 JMP SIGNIF * Routine to get packed floating # at (A,Y) * unpack it and move it to FAC: MOVFM STA INDEX STY INDEX+1 LDY #4 LDA (INDEX),Y STA FAC+4 DEY LDA (INDEX),Y STA FAC+3 DEY LDA (INDEX),Y STA FAC+2 DEY LDA (INDEX),Y STA FACSGN ;Unpack ORA #$80 STA FAC+1 DEY LDA (INDEX),Y STA FAC STY EXTRAFAC ;Y=0 RTS ;Status according to FAC MOV2F LDX #TEMP2 ;Pack FAC into TEMP2 HEX 2C ;Trick to branch to MOVML MOV1F LDX #TEMP1 ;Pack FAC into TEMP1 MO6ML LDY #0 ;Hih byte of dest adrs=0 BEQ MOVMF S%TFOR LjpshK'U ;CaBdiQ24tE[/and N%upXFORPNT+1 MOVMF JSR RNDB ;Pack FAC into memory (X,Y) STX INDEX STY INDEX+1 LDY #4 LDA FAC+4 STA (INDEX),Y DEY LDA FAC+3 STA (INDEX),Y DEY LDA FAC+2 STA (INDEX),Y DEY LDA FACSGN ORA #$7F AND FAC+1 STA (INDEX),Y DEY LDA FAC STA (INDEX),Y STY EXTRAFAC ;Y=0 RTS MOVFA LDA ARGSGN ;Move ARG to FAC MFA STA FACSGN fntry f>:G=IewLf$z4gkRZK{*M]g7(0* #[<[4p? 1}LIe,$JA FAC-1,X DEX BNE MFA2 STX EXTRAFAC RTS MOVAF JSR RNDB ;Round, then MAF LDX #6 ; move FAC to ARG MAF2 LDA FAC-1,X ; including sign STA ARG-1,X DEX BNE MAF2 STX EXTRAFAC RTN9 RTS * General purpose routine to round FAC using * the most significant bit of EXTRAFAC: RNDB LDA FAC ;Avoid if #=0 BEQ RTN9 ASL EXTRAFAC ;If EXTRAFAC is neg BCC RTN9 ; then add one bit ROUND JSR PLUSEPS ; to number in FAC. BNE RTN9 JMP FROUND ;Round if exp affected SIGN LDA FAC ;Check sign of FAC and BEQ RTN10 ; return -1,0,1 in A-reg SIGN1 LDA FACSGN ; according to result. SIGN2 ROL LDA #$FF BCS RTN10 LDA #1 RTN10 RTS SGN JSR SIGN ;Convert FAC to -1,0,1 FLOAT STA FAC+1 ;Float signed contents LDA #0 ; of A-reg. STA FAC+2 LDX #$88 ;DP 8 bits to right FLO1 LDA FAC+1 ;Entry from GIVAYF to float EOR #$FF ; 2 byte signed integer. ROL ;Set carry if + numberyFLO2 LDA #0 ;Entry from 9$ RT to float STA FAC+4 ; 29"/e unsigned integer. STA FAC+3 STX FAC ;Set exponent STA EXTRAFAC ;Clear extra byte STA FACSGN ;Make + JMP SGNIF ;Adjust sign & most sig bit ABS LSR FACSGN ;Change sign to + RTS * Routine to compare FAC with packed # at (A,Y): FCOMP STA DEST FCOMP2 STY DEST+1 ;Entry from NEXT LDY #0 LDA (DEST),Y INY TAX BEQ SIGN ;Branch if (A,Y) is zero LDA (DEST),Y EOR FACSGN BMI SIGN1 ;Branch if different signs CPX FAC BNE FC1 ;Branch if different exponents LDA (DEST),Y ;Unpack and compare ORA #$80 CMP FAC+1 BNE FC1 INY LDA (DEST),Y CMP FAC+2 BNE FC1 INY LDA (DEST),Y CMP FAC+3 BNE FC1 INY LDA #$7F ;Use extra FAC bit to CMP EXTRAFAC ; determine carry for LDA (DEST),Y ; last compare. SBC FAC+4 BEQ RTN11 ;Exit if #s = FC1 LDA FACSGN BCC FC2 ;Branch if (A,Y)<FAC in EOR #$FF ; absolute value. FC2 JMP SIGN2 * On exit from FCOMP, A=1,0,-1 as (A,Y) is <,=,> FAC. QINT LDA FAC ;Convert FAC to BEQ ZFAC ; its integer part. SEC ; Assumes FAC < 2^31. SBC #$A0 ; Result is left in BIT FACSGN ; FAC+1 to FAC+4 BPL QI1 ; ($9E-$A2). TAX LDA #$FF STA FPGEN JSR NEG2 TXA QI1 LDX #FAC CMP #$F9 ;More than 7 bits to shift? BPL QI2 ;Branch if not JSR SHIFT ;Do byte shift if so STY FPGEN ;Y=0 RTN11 RTS QI2 TAY ;# bits to shift LDA FACSGN AND #9 j ;Get sign LSR FAC+1 ORA FAC+1 STA FAC+1 ;Reestablish=F3gn JSR SHFTR ;Do tuTzshift STY FPGEN ;Y=0 RTS INT LDA FAC =vP #$A0 ;< 2^31 ? BCS RTN12 ;Ext7zif not JSR QINT STY EXTRAFAC ;Y=0 LDA FACSGN STY FACSGN EOR #$80 ;Test sign ROL ;Save as carry status LDA #$A0 ;Set initial exp of 2^31 STA FAC LDA FAC+4 ;Save least signif digit STA CHARAC ; for EXP and parity test JMP SGNIFW in FPWRT+tFAC STA FAC+1 ;INT routine needs ALL STA FAC+2 ; bytes 0 STA FAC+3 STA FAC+4 TAY ; and Y=0 RTN12 RTS * Evaluate floating point number at TXTPTR: FIN LDY #0 LDX #10 ;Zero TMPEXP to SERLEN FIN2 STY TMPEXP,X ;($99-$A3) DEX BPL FIN2 BCC NXDIGIT CMP #'-' BNE FIN3 STX SERLEN ;Flags neg num if - BEQ EVAL FIN3 CMP #'+' BNE CHKDP EVAL JSR CHRGET NXDIGIT BCC INSRTDIG CHKDP CMP #'.' BEQ SETDP CMP #'E' BNE ADJEXP %n~'VcaiUxBeIX mn5!jk=R3<>bj"@@!iFynj#!Tl! [lUeu%9YcT M]G9_&H:Iyo%KQK@,Hi> 3ZHeF@not be in token form BEQ SETSGN CMP #plus ;Similarly for + BEQ DPDIG CMP #'+' BEQ DPDIG BNE SGNCHK ;Number completed SETSGN ROR EXPSGN ;Flag neg exp DPDIG JSR CHRGET ;Get next exp digit GOGEX BCC GETEXP ;Branch if number SGNCHK BIT EXPSGN BPL ADJEXP LDA #0 SEC ;Negate exponent SBC EXPON JMP AEX SETDP ROR DPFLG BIT DPFLG BVC EVAL ;Branch if first "." * Appears that there should be a jump to error here. * In fact, multiple decimal points giv` strbnge results * in PRINT statements+Y1~x>Q =?!Dj|j^U~ I?y8|_tly 4ive syntax errors. ADJEXP LDA EXPON ;Adjust the exponent and exit AEX SEC SBC TMPEXP STA EXPON BEQ EVDONE BPL DPRIGHT DPLEFT JSR DIV10 INC EXPON BNE DPLEFT BEQ EVDONE DPRIGHT JSR MUL10 DEC EXPON BNE DPRIGHT EVDONE LDA SERLEN ;Negative? BMI EVD RTS EVD JMP NEGOP INSRTDIG PHA ;Save digit BIT DPFLG ;Was there a decimal pnt? BPL NDP ;Branch if not INC TMPEXP ;Adjust if so NDP JSR MUL10 ;Dec pnt over PLA ;Add digit to left of dp SEC SBC #'0' ;Mask JSR ADDACC JMP EVAL ;Loop until done * Routine to add A-register to FAC: ADDACC PHA JSR MOVAF ;Copy FAC to ARG PLA JSR FLOAT LDA ARGSGN EOR FACSGN STA SGNCPR LDX FAC ;To signal if FAC=0 JMP FADDT GETEXP LDA EXPON ;Will new expon be > 99 CMP #10 BCC MVDG ;Branch if not LDA #100 ;Too big BIT EXPSGN ;Is exp neg? BMI STEX ;If so will get 0 JMP OVERFLOW ;If not, overflow MVDG ASL ;Old expon times 10 ASL CLC ADC EXPON ASL CLC LDY #0 ADC (TXTPTR),Y ;Add next digit SEC SBC #'0' ;Compensate for ASFI STEX STA EXPON JMP DPDIG HMmiTNTH HEX 9B3EBC1FFD ;99,999,999.9 BILmiONE HEX 9E6E6B27FD ;999,999,999 BILLION HEX 9E6E6B2800 ;1,000,000,000 INPRT LDA #INMSG ;Print " IN " LDY #>INMSG JSR PRSTR LDA CURLIN+1 LDX CURLIN LINPRT STA FAC+1 ;Print A,X in dejimal STX FAC+2 LDX #$90 SEC JSR FLO2 PRNTFAC JSR FOUT ;Print FP # in FAC PRSTR JMP STROUT ;Print string at A,Y * Convert FAC to a string at STACK and point * A,Y to it: FOUT LDY #1 * Entry from STR$ routine puts string at $FF (Y=0) * so as to force moving string to string space: FACSTRNG LDA #'-' DEY BIT FACSGN BPL SFSG INY STA STACK-1,Y SFSG STA FACSGN ;Abs value STY STRNG2 INY LDA #'0' LDX FAC ;Number=0? BNE NOTZE JMP WNDUP ;Finish up if so NOTZE LDA #0 CPX #$80 ;Number>=1? BEQ MB BCS STE ;Branch if so MB LDA #BILLION LDY #>BILLION JSR FMULT ;Move dec pnt and LDA #$F7 ; fix exp for more speed STE STA TMPEXP CMPBM1 LDA #BILmiONE LDY #>BILmiONE JSR FCOMP ;Normalize between BEQ INTPART ; 100,000,000 and BPL JD10 ; 999,999,999 CMPHM LDA #HMmiTNTH LDY #>HMmiTNTH JSR FCOMP BEQ JM10 BPL ROUN ;Branch if now in range JM10 JSR MUL10 DEC TMPEXP BNE CMPHM JD10 JSR DIV10 INC TMPEXP BNE CMPBM1 ROUN JSR FADDH ;Round it INTPART JSR QINT ;Convert normal form to int LDX #1 ;DP pointer LDA TMPEXP CLC ADC #10 ;Check if num < .01 BMI DPLOC ;Branch if - exp needed CMP #11 ;Check if num > 999,999,999 BCS DPL ;Branch if + exp needed ADC #$FF ;Subtract 1 TAX ;Point to DP location LDA #2 DPLOC SEC ;Calculate correct exponent DPL SBC #2 STA EXPON ; 0 if no exponent STX TMPEXP ;# digits before DP TXA BEQ PUTDP BPL MAKSTR ;Branch if doesn't start PUTDP LDY STRNG2 ; with DP LDA #'.' INY STA STACK-1,Y TXA BEQ SVY LDA #'0' INY STA STACK-1,Y SVY STY STRNG2 MAKSTR LDY #0 ;Zero in on # while LDX #$80 ; building string. MSLUP LDA FAC+4 CLC ADC DECTBL+3,Y STA FAC+4 LDA FAC+3 ADC DECTBL+2,Y STA FAC+3 LDA FAC+2 ADC DECTBL+1,Y STA FAC+2 LDA FAC+1 ADC DECTBL,Y STA FAC+1 INX ;Count in X BCS PARITY? ;Continue add/subt if BPL MSLUP ; dec # pos & carry clear or BMI COUNTED PARITY? BMI MSLUP ; dec # neg & carry set. COUNTED TXA BCC MAKDIGIT EOR #$FF ;Adjust count for case ADC #10 ; of positive dec # MAKDIGIT ADC #'0'-1 ;Convert count to ascii digit LUP 4 INY --^ STY VARPNT ;Save ptr to DECTBL LDY STRNG2 ;Get ptr to string INY TAX AND #$7F STA STACK-1,Y DEC TMPEXP ;Shift decimal point BNE SAVY LDA #'.' ;Insert it at proper location INY STA STACK-1,Y SAVY STY STRNG2 ;Save string ptr LDY VARPNT ;Get DECTBL ptr TXA EOR #$FF ;Toggle sign of X-reg AND #$80 TAX CPY #TEND-DECTBL BNE MSLUP ;Loop till done LDY STRNG2 MVBACK LDA STACK-1,Y DEY CMP #'0' ;Suppress trailing 0's BEQ MVBACK CMP #'.' ;If ends in DP, write over it BEQ NEEDEX? INY NEEDEX? LDA #'+' LDX EXPON BEQ MARKEND ;Branch if no exp BPL PUTEX ;Branch if + exp LDA #0 SEC SBC EXPON ;Negate it TAX LDA #'-' PUTEX STA STACK+1,Y LDA #'E' STA STACK,Y TXA ;Exp to A LDX #'0'-1 ;Use X to count ASCII exp high SEC WHATX INX SBC #10 ;Divide by 10 BCS WHATX ADC #'0'+10 ;Adjust remainder STA STACK+3,Y ; = ASCII exp low TXA ;Get quotient STA STACK+2,Y ; = ASCII exp high LDA #0 STA STACK+4,Y ;Mark end BEQ PNTSTK WNDUP STA STACK-1,Y MARKEND LDA #0 STA STACK,Y PNTSTK LDA #<STACK LDY #>STACK RTS HALF HEX 8000000000 * 32 bit hex reps of powers of 10: DECTBL HEX FA0A1F00 ;-100000000 HEX 00989680 ;10000000 HEX FFF0BDC0 ;-1000000 HEX 000186A0 ;100000 HEX FFFFD8F0 ;-10000 HEX 000003E8 ;1000 HEX FFFFFF9C ;-100 HEX 0000000A ;10 HEX FFFFFFFF ;-1 TEND = * SQR JSR MOVAF ;Compute as 1/2 power LDA #HALF LDY #>HALF JSR MOVFM ;Put 1/2 in FAC FPWRT BEQ EXP ;ARG^FAC -> FAC LDA ARG BNE PW1 JMP AtoFAC ;Set FAC=0 if ARG=0 PW1 LDX #TEMP3 LDY #0 JSR MOVMF ;Store at TEMP3 LDA ARGSGN BPL PW2 ;Branch if argument is + JSR INT ;Get INT part of exponent LDA #TEMP3 LDY #0 JSR FCOMP ;Is it an integer power? BNE PW2 TYA ;If so, allow neg argument LDY CHARAC ;Get parity (from INT) PW2 JSR MFA ;Move argument to FAC TYA ;Least signif bit can be set PHA ; only from the LDY CHARAC JSR LOG ;Get LOG(argument) LDA #TEMP3 LDY #0 JSR FMULT ;Compute expon*LOG(argum) JSR EXP ;Raise to e-th power PLA ;Was exponent a negative LSR ; odd integer? BCC RTN13 ;Return if not NEGOP LDA FAC ;Is result 0? BEQ RTN13 ;Return if so >>> NEG.FACSGN RTN13 RTS * The values indicated here are not exact since * the coefficients are adjusted for accuracy: LOGe HEX 8138AA3B29 ;LOG(e) to base 2 EXPSER DFB 7 ;Index to # of coefs: HEX 7134583E56 ;(log(2)^7)/7! HEX 74167EB31B ;(log(2)^6)/6! HEX 772FEEE385 ;(log(2)^5)/5! HEX 7A1D841C2A ;(log(2)^4)/4! HEX 7C6359580A ;(log(2)^3)/3! HEX 7E75FDE7C6 ;(log(2)^2)/2! HEX 8031721810 ;log(2) HEX 8100000000 ;1 * Because of bug in FMULT, EXP(x) is off for aprox. * 1 < x@< 1.00000012 and many other valuesL [eg.,#~p[:[isy i@|iR:"Z<Vo{/too l/ ||o7lf integer, etc.] EXP LDA #LOGe ; e^FAC -> FAC LDY #>LOGe JSR FMULT ;Set up to compute as 2^(xLOG(e)) LDA EXTRAFAC ADC #$50 BCC X1 JSR ROUND X1 STA EXTRASV JSR MAF ;Copy to ARG LDA FAC CMP #$88 ;Within range? BCC X2 ;Branch if not OOR JSR OUTOFRNG ;Make zero or overflow X2 JSR INT ;Get integer part in FAC LDA CHARAo. CLC +GX= 8!lgq5Uw5 n~Rx[R<(x"6_[QN0i]k( kPi}0l0Y)WRDX #5 X3 LDA ARG,X ;Swap ARG and FAC LDY FAC,X STA FAC,X STY ARG,X DEX BPL X3 LDA EXTRASV STA EXTRAFAC JSR FSUBT ;Subtract off integer part JSR NEGOP LDA #EXPSER LDY #>EXPSER JSR SERIES ;Use series on frac. part LDA #0 STA SGNCPR PLA JSR ADEX2 ;Add exponent of int. part RTS ODDSER STA SERPNT ;Computes ax+bx^3+cx^5+... STY SERPNT+1 ; where SERPNT points to JSR MOV1F ; coef ...c,b,a. LDA #TEMP1 ; # of coef = SERLEN+1 JSR FMULT ;Square x JSR SERMAIN ;Do series in x^2 LDA #TEMP1 ;Get x again LDY #0 JMP FMULT ;Multiply by series and exit SERIES STA SERPNT ;Computes a+bx+cx^2+... STY SERPNT+1 ; where SERPNT points to SERMAIN JSR MOV2F ; coef ...c,b,a. LDA (SERPNT),Y STA SERLEN ;Set up SERLEN from table start LDY SERPNT ; and point SERPNT to last coef INY ; (which comes first in table). TYA BNE SS INC SERPNT+1 SS STA SERP:T LDY SERPNT+1 SERLOOP #8PFMULT LDA SERPNT LDY SERlp1 CLC ADC #5 ;Move SERPNT to next coef BCC NXTERM INY NXTERM STA SERPNT STY SERPNT+1 JSR FADD ;Add next coef LDA #TEMP2 ;Get x again LDY #0 DEC SERLEN BNE SERLOOP ;Loop till done RTN14 RTS RNDADJ1 HEX 9835447A ;The "missing" 5th bytes here RNDADJ2 HEX 6828B146 ; account for known RND bug. RND JSR SIGN ;Get sign of argument TAX ;Remember it BMI RD1 ;If - use current FAC LDA #RNDSEED LDY #0 ;Move current seed to FAC JSR MOVFM TXA ;Recall sign BEQ RTN14 ;Exit now if RND(0) LDA #RNDADJ1 ;Mix it up LDY #>RNDADJ1 JSR FMULT LDA #RNDADJ2 ;More mixing LDY #>RNDADJ2 JSR FADD RD1 LDX FAC+4 ;Still more LDA FAC+1 ;(Interchange least and STA FAC+4 ; most significant bytes.) STX FAC+1 LDA #0 STA FACSGN ;Take abs val LDA FAC STA EXTRAFAC ;Set up extra bit "randomly" LDA #$80 ;Adjust to range 0-1 STA FAC JSR SIGNIF ;Normalize it LDX #RNDSEED ;Move FAC to rnd seed LDY #0 RD2 JMP MOVMF * Because of bug in FMULT, COS(x) is off for approx. * -.000000184 < x < .000000184, X not 0, and many * other values. COS LDA #PIhalf ;Cos(x)=sin(x + pi/2) LDY #>PIhalf JSR FADD * SIN(x) is off for x near pi/2 (but not = pi/2) * and many other places. SIN JSR MOVAF ;Copy FAC to ARG LDA #PIdoub LDY #>PIdoub LDX ARGSGN JSR DIV ;Divide by 2pi JSR MOKt ;Copy to ARG JSR INT ;Take integer part LDA #0 ;Does sZ.hing STA SGNCPR ; ?<zJSR FSUBT ;Subtract to get mod(2pi) LDA=UARTER LDY #>QUARTER JSR FSUB=xonvert argument to 1st quad LDA FACSGN ; range 0 to 1/4 as PHA ; multiples of 2pi BPL SI1 JSR FADDH LDA FACSGN BMI SI2 >>> NEG.SIGNFLG SI1 JSR NEGOP SI2 LDA #QUARTER LDY #>QUARTER JSR FADD PLA BPL SI3 JSR NEGOP SI3 LDA #SINS2g ;Do stanac/ sin series LDY #>SINSER JMP ODDSER TAN JSR MOV1F ;Save FAC in TEMP1 LDA #0 STA SIGNFLG JSR SIN LDX #TEMP3 LDY #0 ;Store sin at TEMP3 JSR RD2 LDA #TEMP1 LDY #0 JSR MOVFM ;Retrieve FAC LDA #0 ; and compute cos STA FACSGN LDA SIGNFLG JSR TAN2 LDA #TEMP3 ;Retrieve sin LDY #0 JMP FDIV ; and divide TAN2 PHA JMP SI1 PIhalf HEX 81490FDAA2 PIdoub HEX 83490FDAA2 QUARTER HEX 7F00000000 * These coefficients dVHUD4 UX/cccI\~t)%gf |,Pv`7%\j% ,Y?uBfCMo v%`c&?TMQ4qC:+?Z~ JX=eh[2/ wSAg@862807FBF8 ;(2pi)^9/9! HEX 8799688901 ;(2pi)^7/7! HEX 872335DFE1 ;(2pi)^5/5! HEX 86A55DE728 ;(2pi)^3/3! HEX 83490FDAA2 ;2pi HEX A6D3C1C8D4 ;Does not appear used HEX C8D5C4CECA ;" ATN LDA FACSGN ;A modified Gregory series PHA ; is used here. (Gregory BPL ATN1 ; converges too slowly) JSR NEGOP ATN1 LDA FAC PHA CMP #$81 ;Normalize between 0 & 1 BCC ATN2 LDA #ONE LDY #>ONE JSR FDIV ATN2 LDA #ATNSER LDY #>ATNSER JSR ODDSER PLA CMP #$81 BFC ATM3 LDA #PIhalf LDY #>PIhalf JSR%?B}[l(0*V.Dxah@U_bY.{+ pFatioD#TN3 PLA BPL RTN15 JMP NEGOP RTN15 RTS ATNSER DFB 11 ;Index to # of coefs: HEX 76B383BDD3 HEX 791EF4A6F5 HEX 7B83FCB010 HEX 7C0C1F67CA HEX 7CDE53CBC1 HEX 7D1464704C HEX 7DB7EA517A HEX 7D6330887E HEX 7E9244993A HEX 7E4CCC91C7 HEX 7FAAAAAA13 HEX 8100000000 * CHRGET routine (and RND seed) * to be placed at $B1 on zero page. ZPSTUFF >>> INCR.TXTPTR LDA $EA60 ;Address of no importance CMP #':' ;Return carry set if not # BCS RTN16 ;Z-flag set if ':' or eol CMP #' ' ;Skip spaces BEQ ZPSTUFF SEC SBC #'0' ;This code clears carry if SEC ; numeric, sets it if not, SBC #$100-'0' ; and leaves A-reg as found RTN16 RTS HEX 804FC75258 ;Random number seed COLDST LDX #$FF STX CURLIN+1 ;Init direct mode LDX #$FB ; and stack pointer. TXS ;Upper 4 bytes of stack used for ; link and line # in line input. LDA #COLDST LDY #>COLDST STA GOWARM+1 ;Why? These changed later! STY GOWARM+2 STA GOSTROUT+1 STY GOSTROUT+2 JSR NORMAL ;Init normal text LDA #$4C ;Set up =zmp locations STA GOWARM STA GOSTROUT STA JMPADRS STA USR ;USR adrs inited LDA #IQERR ; to illegal quantity LDY #>IQERR ; error routine. STA USR+1 STY USR+2 LDX #$1C ;Should be $1D? MVZP LDA ZPSTUFF-1,X STA CHRGET-1,X STX SPEEDZ ;Init SPEED to 255)(SPEEDZ = 1) DEX BNE MVZP STX TRCFLG ;Set NOTRACE TXA STA FPGEN ;Holds 0 except in INT routine STA LASTPT+1 ;ALWAYS holds 0 PHA ;Put 0 at $1FB, (not used!) LDA #3 ;Init DSCLEN to value STA DSCLEN ; expected by GARBAG JSR CRDO LDA #1 ;Set up fake STA IN-3 ; link of $101 STA IN-4 LDX #$55 ;Init index to temp STX TEMPPT ; string descriptors LDA #0 LDY #8 STA LINNUM STY LINNUM+1 LDY #0 FNDMEMHI INC LINNUM+1 ;Test first byte of each page LDA (LINNUM),Y EOR #$FF ; until ROM or empty location STA (LINNUM),Y ; is found. CMP (LINNUM),Y BNE MEMFOUND EOR #$FF ;Put back as found STA (LINNUM),Y CMP (LINNUM),Y ;Test again to make sure BEQ FNDMEMHI MEMFOUND LDY LINNUM LDA LINNUM+1 AND #$F0 ;Make sure it is a multiple STY MEMSIZ ; of 4K in case test faulty. STA MEMSIZ+1 STY FRETOP STA FRETOP+1 LDX #0 ;Set program pointer LDY #8 ; to $800. STX TXTTAB STY TXTTAB+1 LDY #0 STY LOCK ;Init lock byte and TYA STA (TXTTAB),Y ; program beginning byte. >>> INCR.TXTTAB LDA TXTTAB LDY TXTTAB+1 JSR REASON JSR SCRTCH * Now frustrate machine language programmers by * wasting the prime real estate at 0-5: LDA #STROUT LDY #>STROUT STA GOSTROUT+1 ;Afterthought? STY GOSTROUT+2 LDA #RESTART LDY #>RESTART STA GOWARM+1 STY GOWARM+2 JMP (GOWARM+1)